;-*- Mode:LISP; Package:USER; Base:8 -*-
(DECLARE
 (SPECIAL BRUSH PAINT PAINT-SCREEN PAINT-LIST ALTERNATE-PAINT
        PAINT-MENU SELECT-MENU AREA-MENU DRAW-MENU
        BRUSH-LOW-X BRUSH-LOW-Y BRUSH-HIGH-X BRUSH-HIGH-Y
        BRUSH-CURSOR BRUSH-CURSOR-ARRAY
        BRUSH-PHASE BRUSH-CURSOR-X BRUSH-CURSOR-Y
        PAINT-CLOCK PAINT-CLOCK-RATE PAINT-DEFAULT-CLOCK-RATE BLINK-CLOCK-RATE
        PAINT-AREA-Y PAINT-AREA-X PAINT-DISPATCH-ALWAYS
        MOUSE-TOP-SWITCH MOUSE-TOP-SWITCH-HOLD MOUSE-MID-SWITCH MOUSE-BOT-SWITCH
        MOUSE-MIDSW-HOLD  ;IF T, WILL NOT DISPATCH TO COMMAND UNTIL MIDSW RELEASED
        MOUSE-BOTSW-HOLD  ;SET TO NIL IF BOTSW SEEN OFF.
        MOUSE-X MOUSE-Y PAINT-MODE PAINT-BRUSH-INHIBIT-BLINK
        PAINT-CURRENT-MENU PAINT-SAVED-SCREEN
        PAINT-MODE-PC-PPR PAINT-MODE-STREAM
        PAINT-CONSOLE-IO-PC-PPR CONSOLE-IO-PC-PPR
        PAINT-LABELING-PC-PPR PAINT-LABELING-STREAM
        PAINT-DLC-STATE PAINT-DLC-MODE PAINT-DLC-BASE-X PAINT-DLC-BASE-Y
        PAINT-SUBC-X PAINT-SUBC-Y PAINT-SUBC-PHASE
        PAINT-EXIT-FLAG PAINT-ARG-STRING PAINT-TEXT-HOLDING-STRING
        PAINT-TEXT-FONT PAINT-PICTURE-LIST
))

 (DECLARE (SPECIAL TV-ALU-AND))

        (SETQ TV-ALU-AND 1_3)

(DEFCLASS PAINT-AREA-CLASS OBJECT-CLASS
     (  PAINT-AREA-ARRAY
        PAINT-AREA-X            ;LOW X COORD OF AREA WITHIN ARRAY
        PAINT-AREA-Y            ;LOW Y COORD OF AREA WITHIN ARRAY
        PAINT-AREA-X-SIZE       ;X-SIZE IN # BITS
        PAINT-AREA-Y-SIZE       ;Y-SIZE IN # BITS
        PAINT-AREA-BUFFER-ARRAY ;NIL OR ANOTHER ARRAY TO BUFFER AREA
  )
)

(DEFMETHOD (PAINT-AREA-CLASS :INSIDE-P) (ARY X Y)
     (AND (EQ ARY PAINT-AREA-ARRAY)
          (NOT (< X PAINT-AREA-X))
          (NOT (< Y PAINT-AREA-Y))
          (< X (+ PAINT-AREA-X PAINT-AREA-X-SIZE))
          (< Y (+ PAINT-AREA-Y PAINT-AREA-Y-SIZE))))

(DEFMETHOD (PAINT-AREA-CLASS :COPY-TO)
           (TO-ARY &OPTIONAL (TO-X 0) (TO-Y 0) (ALU-OP TV-ALU-SETA))
   (BITBLT ALU-OP PAINT-AREA-X-SIZE PAINT-AREA-Y-SIZE
           PAINT-AREA-ARRAY PAINT-AREA-X PAINT-AREA-Y
           TO-ARY TO-X TO-Y))

(DEFMETHOD (PAINT-AREA-CLASS :COPY-TO-CENTERED)
           (TO-ARY C-X C-Y &OPTIONAL (ALU-OP TV-ALU-SETA))
   (<- SELF ':COPY-TO TO-ARY
                      (- C-X (// PAINT-AREA-X-SIZE 2))
                      (- C-Y (// PAINT-AREA-Y-SIZE 2))
                      ALU-OP))

(DEFMETHOD (PAINT-AREA-CLASS :COPY-TO-BUFFER) NIL       ;DUPLICATE AREA IN BUFFER
  (PROG (BA-AT BITS-PE BA-D1-BITS PA-D1-BITS)
   (COND ((NULL PAINT-AREA-BUFFER-ARRAY)
          (SETQ BA-AT (ARRAY-TYPE PAINT-AREA-ARRAY))
          (SETQ BITS-PE (CDR (ASSQ BA-AT ARRAY-BITS-PER-ELEMENT)))
          (SETQ PA-D1-BITS (* BITS-PE PAINT-AREA-X-SIZE))
          (SETQ BA-D1-BITS (* (// (+ PA-D1-BITS 31.) 32.) 32.))  ;ASSURE MULT OF 32. SO
                                                        ;BITBLT WINS.
          (SETQ PAINT-AREA-BUFFER-ARRAY
                (MAKE-ARRAY NIL (ARRAY-TYPE PAINT-AREA-ARRAY)
                            (LIST (// BA-D1-BITS BITS-PE) PAINT-AREA-Y-SIZE)))))
   (<- SELF ':COPY-TO PAINT-AREA-BUFFER-ARRAY)))

(DEFMETHOD (PAINT-AREA-CLASS :COPY-FROM-BUFFER-CENTERED)
           (TO-ARY C-X C-Y &OPTIONAL (ALU-OP TV-ALU-SETA))
   (BITBLT ALU-OP PAINT-AREA-X-SIZE PAINT-AREA-Y-SIZE
           PAINT-AREA-BUFFER-ARRAY 0 0
           TO-ARY (- C-X (// PAINT-AREA-X-SIZE 2)) (- C-Y (// PAINT-AREA-Y-SIZE 2))))

(DEFSTRUCT (PAINT-LINE-ITEM) ;ALSO USED FOR CIRCLES
        PAINT-LINE-HANDLER      ;NAMED-STRUCTURE-HANDLER
        PAINT-LINE-TYPE         ;LINE OR CIRCLE
        PAINT-LINE-STATUS       ;IN OR OUT
        PAINT-LINE-MODE         ;0S 1S OR XOR
        PAINT-LINE-X0           ;CENTER OF CIRCLE OR ENDPOINT OF LINE
        PAINT-LINE-Y0
        PAINT-LINE-X1           ;RADIUS OF CIRCLE OR ENDPOINT OF LINE
        PAINT-LINE-Y1           ;UNUSED IF CIRCLE
)

(DEFSTRUCT (PAINT-PATH)
        PAINT-PATH-HANDLER      ;NAMED-STRUCTURE-HANDLER
        PAINT-PATH-STATUS
        PAINT-PATH-MODE
        PAINT-PATH-POINTS-ARRAY
)

(DEFSTRUCT (PAINT-TEXT)
        PAINT-TEXT-NAME
        PAINT-TEXT-TEXT
        PAINT-TEXT-FONT
        PAINT-TEXT-XPOS
        PAINT-TEXT-YPOS
)

(DEFUN PAINT-INIT NIL
   (MAKUNBOUND 'PAINT-LABELING-PC-PPR)
   (MAKUNBOUND 'PAINT-LABELING-STREAM)
   (MAKUNBOUND 'PAINT-MODE-PC-PPR)
   (MAKUNBOUND 'PAINT-MODE-STREAM)
   (MAKUNBOUND 'PAINT-CONSOLE-IO-PC-PPR)
   (MAKUNBOUND 'PAINT-MENU)
   (MAKUNBOUND 'SELECT-MENU)
   (MAKUNBOUND 'AREA-MENU)
   (MAKUNBOUND 'DRAW-MENU)
)

(DEFUN PAINT (&OPTIONAL (INPUT-ROUTINE 'MOUSE) (INITP T))
  (PROG (DX DY MOUSE-TOP-SWITCH MOUSE-TOP-SWITCH-HOLD MOUSE-MID-SWITCH MOUSE-MIDSW-HOLD
           MOUSE-BOT-SWITCH MOUSE-BOTSW-HOLD TEM
          (MOUSE-X 300) (MOUSE-Y 300) (PAINT-CLOCK 0) (BLINK-CLOCK 0)
          PAINT-MODE NEW-PAINT-MODE PAINT-BRUSH-INHIBIT-BLINK PAINT-CURRENT-MENU
          OLD-CONSOLE-IO-PC-PPR PAINT-DISPATCH-ALWAYS PAINT-EXIT-FLAG PAINT-ARG-STRING
          CH PAINT-TEXT-HOLDING-STRING PAINT-TEXT-FONT PAINT-PICTURE-LIST)
         (COND ((NOT (ZEROP (SCREEN-PLANE-MASK TV-DEFAULT-SCREEN)))
                 (SETQ TV-DEFAULT-SCREEN SI:TV-CPT-SCREEN)
;              (BREAK "TV-DEFAULT-SCREEN not 32 bit." T)
          ))
        (COND ((AND (BOUNDP 'PAINT-SCREEN)              ;JUST TO UNWEDGE IF YOU LOSE
                    (NOT (EQ TV-DEFAULT-SCREEN PAINT-SCREEN)))  ;THIS VERSION ONLY WINS
               (PAINT-INIT)))                   ;FOR 32 BIT TV'S
        (SETQ BRUSH-PHASE NIL)
        (COND ((NULL (BOUNDP 'PAINT-DEFAULT-CLOCK-RATE))
                (SETQ PAINT-DEFAULT-CLOCK-RATE 1)))
        (SETQ PAINT-CLOCK-RATE PAINT-DEFAULT-CLOCK-RATE)
        (COND ((NULL (BOUNDP 'BLINK-CLOCK-RATE))
                (SETQ BLINK-CLOCK-RATE 200)))
        (COND ((NULL (BOUNDP 'PAINT-LABELING-PC-PPR))
               (SETQ PAINT-LABELING-PC-PPR (TV-DEFINE-PC-PPR 'PAINT-LABELING-PC-PPR
                      (LIST (SCREEN-DEFAULT-FONT TV-DEFAULT-SCREEN))
                      'BLINKER-P NIL
                      'MORE-P NIL))
               (SETF (PC-PPR-CHAR-ALUF PAINT-LABELING-PC-PPR) TV-ALU-XOR)
               (SETF (PC-PPR-ERASE-ALUF PAINT-LABELING-PC-PPR) TV-ALU-NOOP)))
        (COND ((NULL (BOUNDP 'PAINT-LABELING-STREAM))
               (SETQ PAINT-LABELING-STREAM (TV-MAKE-STREAM PAINT-LABELING-PC-PPR))))
        (COND ((NULL (BOUNDP 'PAINT-MODE-PC-PPR))
               (SETQ PAINT-MODE-PC-PPR
                     (TV-DEFINE-PC-PPR 'PAINT-MODE-PC-PPR
                                       (LIST (SCREEN-DEFAULT-FONT TV-DEFAULT-SCREEN))
                        'TOP 0          ;THIS IS THE SMALL FROB IN THE UPPER RIGHT THAT
                        'BOTTOM 12.     ;SHOWS THE CURRENT MODE
                        'RIGHT (SCREEN-X2 TV-DEFAULT-SCREEN)
                        'LEFT (- (SCREEN-X2 TV-DEFAULT-SCREEN) 120.)
                        'BLINKER-P NIL
                        'MORE-P NIL
                        'END-LINE-FCN 'TV-BACKSPACE
                        'END-SCREEN-FCN 'TV-HOME))))
        (COND ((NULL (BOUNDP 'PAINT-MODE-STREAM))
               (SETQ PAINT-MODE-STREAM (TV-MAKE-STREAM PAINT-MODE-PC-PPR))))
        (COND ((NULL (BOUNDP 'PAINT-CONSOLE-IO-PC-PPR))
               (SETQ PAINT-CONSOLE-IO-PC-PPR
                     (TV-DEFINE-PC-PPR 'PAINT-CONSOLE-IO-PC-PPR
                                       (LIST (SCREEN-DEFAULT-FONT TV-DEFAULT-SCREEN))
                                       'TOP (- (SCREEN-Y2 TV-DEFAULT-SCREEN) 100)
                                       'RIGHT (// (SCREEN-X2 TV-DEFAULT-SCREEN) 2)
                                       'MORE-P NIL))))
        (SETQ OLD-CONSOLE-IO-PC-PPR CONSOLE-IO-PC-PPR)
        (COND ((NOT (EQ CONSOLE-IO-PC-PPR PAINT-CONSOLE-IO-PC-PPR))
               (TV-DEACTIVATE-PC-PPR CONSOLE-IO-PC-PPR)
               (SETQ CONSOLE-IO-PC-PPR PAINT-CONSOLE-IO-PC-PPR)
               (TV-ACTIVATE-PC-PPR CONSOLE-IO-PC-PPR)))
        (COND (INITP
               (TV-CLEAR-SCREEN)
               (INIT-PAINTS)))
        (COND ((NULL (BOUNDP 'PAINT-MENU))
                (SETQ PAINT-MENU (DEFINE-MENU 'PAINT-MENU
                   '(SELECT-MENU DRAW-MENU AREA-MENU
                     RESTORE-PALLET NORMAL-MODE XOR-MODE EXIT)
                   'OPTION 'ADVANCING))))
        (COND ((NULL (BOUNDP 'SELECT-MENU))
                (SETQ SELECT-MENU (DEFINE-MENU 'SELECT-MENU
                   '(SELECT-BRUSH SELECT-PAINT SELECT-ALTERNATE-PAINT PAINT-MENU EXIT)
                   'OPTION 'ADVANCING))))
        (COND ((NULL (BOUNDP 'AREA-MENU))
                (SETQ AREA-MENU (DEFINE-MENU 'AREA-MENU
                   '(SAVE-SCREEN RESTORE-SCREEN
                     MOUSE-UPPER-LEFT MOUSE-LOWER-RIGHT
                      DEFINE-AREA SHOW-AREA SELECT-MENU PAINT-MENU EXIT)
                   'OPTION 'ADVANCING))))
        (COND ((NULL (BOUNDP 'DRAW-MENU))
               (SETQ DRAW-MENU (DEFINE-MENU 'DRAW-MENU
                   '(DRAW-DIRECT DRAW-LINES-AND-CIRCLES TEXT PAINT-MENU EXIT)
                   'OPTION 'ADVANCING))))
        (SETQ PAINT-TEXT-FONT (SCREEN-DEFAULT-FONT TV-DEFAULT-SCREEN))
        (SETQ PAINT-ARG-STRING (MAKE-ARRAY DEFAULT-ARRAY-AREA 'ART-STRING 50 NIL '(0)))
        (PAINT-SELECT-MODE 'NORMAL-MODE)      ;INITIALIZE PAINT-ARG-STRING BEFORE THIS
        (SETQ PAINT-CURRENT-MENU PAINT-MENU)
        (DISPLAY-MENU PAINT-CURRENT-MENU)
        (SETQ PAINT-SCREEN TV-DEFAULT-SCREEN)
   A    (COND ((SETQ CH (KBD-TYI-NO-HANG))
               (SETQ TEM (LOGAND CH 377))       ;FLUSH BUCKY BITS
               (COND ((= TEM 201)               ;BREAK
                      (SETQ PAINT-EXIT-FLAG T))
                     ((= TEM 204)               ;ESCAPE
                      (KBD-ESC))
                     ((= TEM 207)               ;RUBOUT
                      (COND ((NOT (ZEROP (ARRAY-ACTIVE-LENGTH PAINT-ARG-STRING)))
                             (ARRAY-POP PAINT-ARG-STRING))))
                     ((< TEM 200)
                      (ARRAY-PUSH PAINT-ARG-STRING TEM)))))   ;STORE CHAR
        (COND (PAINT-EXIT-FLAG
               (TV-DEACTIVATE-PC-PPR CONSOLE-IO-PC-PPR)
               (SETQ CONSOLE-IO-PC-PPR OLD-CONSOLE-IO-PC-PPR)
               (TV-ACTIVATE-PC-PPR CONSOLE-IO-PC-PPR)
               (RETURN T)))
        (MULTIPLE-VALUE (DX DY MOUSE-TOP-SWITCH MOUSE-MID-SWITCH MOUSE-BOT-SWITCH)
                        (FUNCALL INPUT-ROUTINE))
        (SETQ MOUSE-X (+ MOUSE-X DX) MOUSE-Y (- MOUSE-Y DY)) ;upside-down coordinate system, use -dy
        (COND ((< MOUSE-X BRUSH-LOW-X)
               (SETQ MOUSE-X BRUSH-LOW-X))
              ((> MOUSE-X BRUSH-HIGH-X)
                (SETQ MOUSE-X BRUSH-HIGH-X)))
        (COND ((< MOUSE-Y BRUSH-LOW-Y)
               (SETQ MOUSE-Y BRUSH-LOW-Y))
              ((> MOUSE-Y BRUSH-HIGH-Y)
                (SETQ MOUSE-Y BRUSH-HIGH-Y)))
   A1   (COND (MOUSE-TOP-SWITCH
                (BRUSH-CLEAR)
                (COND ((< MOUSE-Y PAINT-AREA-Y)
                  (COND ((< MOUSE-X PAINT-AREA-X)  ;IN PAINT AREA, SELECT BRUSH
                   (COND ((SETQ TEM (PAINT-SELECT-ARRAY MOUSE-X MOUSE-Y)) ;OR PAINT DIRECTLY
                          (SETQ PAINT TEM)
                          (<- PAINT ':COPY-TO-BUFFER))) )
                   (T (COND ((SETQ TEM (PAINT-SELECT-ARRAY MOUSE-X MOUSE-Y))
                             (SELECT-BRUSH TEM))))) )
                 (T (MULTIPLE-VALUE (NIL NEW-PAINT-MODE)  ;IN MENU AREA, SELECT FROM MENU,
                                                ;OTHERWISE MAYBE COUNT MODE
                        (SELECT-ITEM-FROM-MENU PAINT-CURRENT-MENU MOUSE-X MOUSE-Y
                                        (NULL MOUSE-TOP-SWITCH-HOLD)))
;                       (PAINT-SELECT-MODE NEW-PAINT-MODE)
))
                (SETQ MOUSE-TOP-SWITCH-HOLD T)
                (GO A)))
        (SETQ MOUSE-TOP-SWITCH-HOLD NIL)
        (COND ((NULL MOUSE-BOT-SWITCH)          ;CLEAR THIS IF BOTSW SEEN OFF
               (SETQ MOUSE-BOTSW-HOLD NIL)))
        (COND (NEW-PAINT-MODE
               (COND (MOUSE-MID-SWITCH          ;NEW MODE WAITING TO BE SELECTED, SELECT IT.
                      (PAINT-SELECT-MODE NEW-PAINT-MODE)
                      (SETQ NEW-PAINT-MODE NIL)
                      (MENU-CLEAR-CURSOR PAINT-CURRENT-MENU)))
               (SETQ PAINT-CLOCK -1))     ;JUST <MAYBE> BLINK, DONT PAINT
              (MOUSE-MIDSW-HOLD
               (COND (MOUSE-MID-SWITCH
                      (SETQ PAINT-CLOCK -1))   ;THAT ONE WAS FOR MODE SELECTION
                     (T (SETQ MOUSE-MIDSW-HOLD NIL)))))
        (COND ((AND MOUSE-MID-SWITCH PAINT-BRUSH-INHIBIT-BLINK))   ;IN THIS MODE,
                                ;BLINKING CAUSES TOO MUCH LOSSAGE IF PAINTING
              ((> (SETQ BLINK-CLOCK (1+ BLINK-CLOCK))
                  (COND (MOUSE-MID-SWITCH (* BLINK-CLOCK-RATE 10.))  ;BLINK SLOWER IF PAINTING,
                        (T BLINK-CLOCK-RATE)))          ; BUT DO BLINK OCCAISIONALLY
                (BRUSH-BLINK MOUSE-X MOUSE-Y)
                (SETQ BLINK-CLOCK 0)
                (GO A)))
        (COND ((< (SETQ PAINT-CLOCK (1+ PAINT-CLOCK))
                  PAINT-CLOCK-RATE)
               (GO A)))
        (SETQ PAINT-CLOCK 0)
        (COND ((AND (SETQ TEM (GET PAINT-MODE 'PAINT-COMMAND))
                    (OR MOUSE-MID-SWITCH MOUSE-BOT-SWITCH PAINT-DISPATCH-ALWAYS))
               (BRUSH-CLEAR)
               (FUNCALL TEM)))
        (GO A)
))

(DEFUN PAINT-SELECT-MODE (NEW-MODE &AUX TEM)
  (PROG NIL
       (COND ((EQ NEW-MODE PAINT-MODE)    ;REALLY SAME MODE.
              (RETURN NIL)))
       (COND ((SETQ TEM (GET PAINT-MODE 'PAINT-LEAVING-FCTN))
              (FUNCALL TEM)))
       (COND ((NOT (ZEROP (SETQ TEM (ARRAY-ACTIVE-LENGTH PAINT-ARG-STRING))))
              (ADJUST-ARRAY-SIZE PAINT-ARG-STRING TEM)
              (SETQ PAINT-ARG-STRING
                    (MAKE-ARRAY DEFAULT-ARRAY-AREA 'ART-STRING 50 NIL '(0)))))
       (SETQ PAINT-MODE NEW-MODE)
       (TV-CLEAR-PC-PPR PAINT-MODE-PC-PPR)
       (PRINC PAINT-MODE PAINT-MODE-STREAM)
       (SETQ PAINT-SUBC-PHASE NIL PAINT-SUBC-X NIL)
       (COND ((SETQ TEM (GET PAINT-MODE 'PAINT-ENTERING-FCTN))
              (FUNCALL TEM)))
       (SETQ PAINT-BRUSH-INHIBIT-BLINK (GET PAINT-MODE 'PAINT-BRUSH-INHIBIT-BLINK))
       (SETQ PAINT-DISPATCH-ALWAYS (GET PAINT-MODE 'PAINT-DISPATCH-ALWAYS))
       (COND ((SETQ TEM (GET PAINT-MODE 'PAINT-CLOCK-RATE))
              (SETQ PAINT-CLOCK-RATE TEM))
             (T (SETQ PAINT-CLOCK-RATE PAINT-DEFAULT-CLOCK-RATE)))
       (SETQ MOUSE-MIDSW-HOLD T)))  ;DONT DO ANYTHING UNTIL MIDSW RELEASED

(DEFUN PAINT-SELECT-MENU (NEW-MENU)
   (MENU-CLEAR-CURSOR PAINT-CURRENT-MENU)
   (ERASE-MENU PAINT-CURRENT-MENU)
   (SETQ PAINT-CURRENT-MENU NEW-MENU)
   (DISPLAY-MENU PAINT-CURRENT-MENU)
   (PAINT-SELECT-MODE 'NORMAL-MODE))

(DEFPROP NORMAL-MODE PAINT-COM-NORMAL-MODE PAINT-COMMAND)
(DEFUN PAINT-COM-NORMAL-MODE NIL
   (COND (MOUSE-MID-SWITCH
          (BRUSH-PAINT BRUSH PAINT MOUSE-X MOUSE-Y))
         (MOUSE-BOT-SWITCH
          (BRUSH-PAINT BRUSH ALTERNATE-PAINT MOUSE-X MOUSE-Y))))

(DEFPROP XOR-MODE PAINT-COM-XOR-MODE PAINT-COMMAND)
(DEFUN PAINT-COM-XOR-MODE NIL
   (COND (MOUSE-MID-SWITCH
          (BRUSH-PAINT BRUSH PAINT MOUSE-X MOUSE-Y 'T))
         (MOUSE-BOT-SWITCH
          (BRUSH-PAINT BRUSH ALTERNATE-PAINT MOUSE-X MOUSE-Y))))

(DEFPROP RESTORE-PALLET PAINT-COM-RESTORE-PALLET PAINT-COMMAND)
(DEFUN PAINT-COM-RESTORE-PALLET NIL
       (INIT-PAINTS)
       (PAINT-SELECT-MENU PAINT-MENU))

(DEFPROP SELECT-MENU PAINT-COM-SELECT-MENU PAINT-COMMAND)
(DEFUN PAINT-COM-SELECT-MENU NIL
       (PAINT-SELECT-MENU SELECT-MENU))

(DEFPROP AREA-MENU PAINT-COM-AREA-MENU PAINT-COMMAND)
(DEFUN PAINT-COM-AREA-MENU NIL
       (PAINT-SELECT-MENU AREA-MENU))

(DEFPROP PAINT-MENU PAINT-COM-PAINT-MENU PAINT-COMMAND)
(DEFUN PAINT-COM-PAINT-MENU NIL
       (PAINT-SELECT-MENU PAINT-MENU))

(DEFPROP DRAW-MENU PAINT-COM-DRAW-MENU PAINT-COMMAND)
(DEFUN PAINT-COM-DRAW-MENU NIL
       (PAINT-SELECT-MENU DRAW-MENU))

(DEFPROP DRAW-DIRECT PAINT-COM-DRAW-DIRECT PAINT-COMMAND)
(DEFPROP DRAW-DIRECT T PAINT-BRUSH-INHIBIT-BLINK)
(DEFPROP DRAW-DIRECT 1 PAINT-CLOCK-RATE)
(DEFUN PAINT-COM-DRAW-DIRECT NIL
   (COND (MOUSE-MID-SWITCH
          (AS-2 1 (SCREEN-BUFFER-PIXEL-ARRAY TV-DEFAULT-SCREEN) MOUSE-X MOUSE-Y))
         (MOUSE-BOT-SWITCH
          (AS-2 0 (SCREEN-BUFFER-PIXEL-ARRAY TV-DEFAULT-SCREEN) MOUSE-X MOUSE-Y))))

(DEFPROP SELECT-BRUSH PAINT-COM-SELECT-BRUSH PAINT-COMMAND)
(DEFUN PAINT-COM-SELECT-BRUSH (&AUX TEM)
   (COND ((SETQ TEM (PAINT-SELECT-ARRAY MOUSE-X MOUSE-Y))
          (SELECT-BRUSH TEM)
          (PAINT-SELECT-MODE 'NORMAL-MODE)))
)

(DEFPROP SELECT-PAINT PAINT-COM-SELECT-PAINT PAINT-COMMAND)
(DEFUN PAINT-COM-SELECT-PAINT (&AUX TEM)
   (COND ((SETQ TEM (PAINT-SELECT-ARRAY MOUSE-X MOUSE-Y))
          (SETQ PAINT TEM)
          (<- PAINT ':COPY-TO-BUFFER)
          (PAINT-SELECT-MODE 'NORMAL-MODE)))
)

(DEFPROP SELECT-ALTERNATE-PAINT PAINT-COM-SELECT-ALTERNATE-PAINT PAINT-COMMAND)
(DEFUN PAINT-COM-SELECT-ALTERNATE-PAINT (&AUX TEM)
   (COND ((SETQ TEM (PAINT-SELECT-ARRAY MOUSE-X MOUSE-Y))
          (SETQ ALTERNATE-PAINT TEM)
          (<- ALTERNATE-PAINT ':COPY-TO-BUFFER)
          (PAINT-SELECT-MODE 'NORMAL-MODE)))
)

(DEFUN SELECT-BRUSH (ARG &AUX TEM)
    (SETQ BRUSH ARG)
    (SETQ BRUSH-LOW-X (SETQ TEM (// (<- BRUSH ':PAINT-AREA-X-SIZE) 2)))
    (SETQ BRUSH-HIGH-X (- (SCREEN-X2 TV-DEFAULT-SCREEN) TEM))
    (SETQ BRUSH-LOW-Y (SETQ TEM (// (<- BRUSH ':PAINT-AREA-Y-SIZE) 2)))
    (SETQ BRUSH-HIGH-Y (- (SCREEN-Y2 TV-DEFAULT-SCREEN) TEM))
    (COND ((NULL (BOUNDP 'BRUSH-CURSOR-ARRAY))
            (SETQ BRUSH-CURSOR-ARRAY
                (MAKE-ARRAY DEFAULT-ARRAY-AREA 'ART-1B '(40 40)))   ;ART-1B
;           (SETQ BRUSH-CURSOR-WD-ARRAY
;               (MAKE-ARRAY DEFAULT-ARRAY-AREA 'ART-16B '(100) BRUSH-CURSOR-ARRAY))
                                ;32. ROWS BY 32. BITS
))
;    (DO Y 0 (1+ Y) (= Y 40)
;     (DO X 0 (1+ X) (= X 40)
;       (AS-2 (COND ((OR (NOT (< X (CADDR BRUSH)))
;                        (NOT (< Y (CADDDR BRUSH))))
;                     0)
;                   (T (AR-2 (SCREEN-BUFFER-PIXEL-ARRAY TV-DEFAULT-SCREEN)
;                             (+ (CAR BRUSH) X) (+ (CADR BRUSH) Y))))
;             BRUSH-CURSOR-ARRAY
;             X
;             Y)))
    (<- BRUSH ':COPY-TO-BUFFER)
;    (SETQ BRUSH-CURSOR (LIST 0 0 (COND ((< (CADDR BRUSH) 40) (CADDR BRUSH))
;                                      (T 40))
;                                (COND ((< (CADDDR BRUSH) 40) (CADDDR BRUSH))
;                                      (T 40))))
    (SETQ BRUSH-CURSOR
          (<- PAINT-AREA-CLASS ':NEW 'PAINT-AREA-ARRAY BRUSH-CURSOR-ARRAY
                              'PAINT-AREA-X 0
                              'PAINT-AREA-Y 0
                              'PAINT-AREA-X-SIZE (MIN 40 (<- BRUSH ':PAINT-AREA-X-SIZE))
                              'PAINT-AREA-Y-SIZE (MIN 40 (<- BRUSH ':PAINT-AREA-Y-SIZE))))
)

(DEFUN BRUSH-CLEAR NIL (COND (BRUSH-PHASE (BRUSH-BLINK))))

(DEFUN BRUSH-BLINK (&OPTIONAL X Y)      ;X AND Y BETTER BE GIVEN EXCEPT FROM BRUSH-CLEAR
  (COND (BRUSH-PHASE (SETQ BRUSH-PHASE NIL))
        (T (SETQ BRUSH-CURSOR-X X BRUSH-CURSOR-Y Y BRUSH-PHASE T)))
; (BRUSH-XOR BRUSH-CURSOR BRUSH-CURSOR-ARRAY BRUSH-CURSOR-X BRUSH-CURSOR-Y)
  (<- BRUSH-CURSOR ':COPY-FROM-BUFFER-CENTERED
      (SCREEN-BUFFER-PIXEL-ARRAY TV-DEFAULT-SCREEN)
      BRUSH-CURSOR-X
      BRUSH-CURSOR-Y
      TV-ALU-XOR))

;(DEFUN BRUSH-XOR (BW BH BRUSH-ARRAY X0 Y0)
;       (SETQ X0 (- X0 (// BW 2))
;            Y0 (- Y0 (// BH 2)))
;       (BITBLT TV-ALU-XOR BW BH
;               BRUSH-ARRAY 0 0
;               (SCREEN-BUFFER-PIXEL-ARRAY TV-DEFAULT-SCREEN) X0 Y0))

;(DEFUN BRUSH-XOR (BRUSH BRUSH-ARRAY X0 Y0)
;  (PROG (B-IIDX B-IDX B-OVER B-IBC B-BC B-YC   ;B-IOVER IS 0
;        PICT-IIDX PICT-IDX PICT-IOVER PICT-OVER PICT-TEM PICT-FIELD
;        BITS BRUSH-WD PICT-WD BUFFER-WORDS SCREEN-LINE-LOCATIONS)
;        (SETQ SCREEN-LINE-LOCATIONS (* 2 (SCREEN-LOCATIONS-PER-LINE TV-DEFAULT-SCREEN)))
;        (SETQ BUFFER-WORDS (SCREEN-BUFFER-HALFWORD-ARRAY TV-DEFAULT-SCREEN))
;       (SETQ B-IIDX 0)
;       (SETQ B-IBC (CADDR BRUSH))
;       (SETQ B-YC (CADDDR BRUSH))
;
;       (SETQ X0 (- X0 (// B-IBC 2))
;             Y0 (- Y0 (// B-YC 2)))
;
;       (SETQ PICT-IIDX (+ (LSH X0 -4) (* Y0 SCREEN-LINE-LOCATIONS)))
;       (SETQ PICT-IOVER (LOGAND X0 17))
;
;   XL  (SETQ B-IDX B-IIDX PICT-IDX PICT-IIDX B-OVER 0
;               PICT-OVER PICT-IOVER B-BC B-IBC)
;   L   (SETQ BITS (MIN (- 20 (MAX B-OVER PICT-OVER)) B-BC))
;       (SETQ BRUSH-WD (LDB (+ (LSH B-OVER 6)
;                               BITS)
;                            (AR-1 BRUSH-ARRAY B-IDX)))
;       (SETQ PICT-WD (LDB (SETQ PICT-FIELD
;                             (+ (LSH PICT-OVER 6)
;                                 BITS))
;                           (SETQ PICT-TEM (AR-1 BUFFER-WORDS PICT-IDX))))
;       (SETQ PICT-WD (LOGXOR PICT-WD BRUSH-WD))
;       (AS-1 (DPB PICT-WD PICT-FIELD PICT-TEM) BUFFER-WORDS PICT-IDX)
;       (COND ((ZEROP (SETQ B-BC (- B-BC BITS)))
;               (COND ((ZEROP (SETQ B-YC (1- B-YC)))
;                       (RETURN T))
;                     (T (SETQ B-IIDX (+ B-IIDX 2)
;                              PICT-IIDX (+ PICT-IIDX SCREEN-LINE-LOCATIONS))
;                        (GO XL)))))
;       (COND ((>= (SETQ B-OVER (+ B-OVER BITS)) 20)
;               (SETQ B-OVER 0 B-IDX (1+ B-IDX))))
;       (COND ((>= (SETQ PICT-OVER (+ PICT-OVER BITS)) 20)
;               (SETQ PICT-OVER 0 PICT-IDX (1+ PICT-IDX))))
;       (GO L)
;))

;(DEFUN BRUSH-XOR (BRUSH BRUSH-ARRAY X0 Y0)
;  (PROG (PX PY BX BY BXL BYL)
;        (SETQ PY (- Y0 (// (CADDDR BRUSH) 2))
;              BY (CADR BRUSH)
;              BYL (+ BY (CADDDR BRUSH)))
;   L    (COND ((NOT (< BY BYL))
;               (RETURN T)))
;        (SETQ PX (- X0 (// (CADDR BRUSH) 2))
;              BX (CAR BRUSH)
;              BXL (+ BX (CADDR BRUSH)))
;   L1   (COND ((NOT (< BX BXL))
;               (SETQ BY (1+ BY))
;               (SETQ PY (1+ PY))
;               (GO L)))
;        (COND ((NOT (= 0 (AR-2 BRUSH-ARRAY BX BY)))
;               (AS-2 (LOGXOR (AR-2 (SCREEN-BUFFER-PIXEL-ARRAY TV-DEFAULT-SCREEN) PX PY) 1)
;                     (SCREEN-BUFFER-PIXEL-ARRAY TV-DEFAULT-SCREEN)
;                     PX
;                     PY)))
;        (SETQ PX (1+ PX)
;              BX (1+ BX))
;        (GO L1)))

;(DEFUN BRUSH-PAINT (BRUSH PAINT X0 Y0 &OPTIONAL XOR-MODE
;                 &AUX BUFFER-PIXELS)
;       (SETQ BUFFER-PIXELS (SCREEN-BUFFER-PIXEL-ARRAY TV-DEFAULT-SCREEN))
;;COPY BRUSH TO BRUSH-BUFFER-ARRAY
;       (<- BRUSH ':COPY-TO-BUFFER)
;;CLEAR OUT BRUSH REGION IN PICTURE
;       (<- BRUSH ':COPY-FROM-BUFFER-CENTERED BUFFER-PIXELS X0 Y0 TV-ALU-ANDCA)
;;COMBINE PAINT WITH BRUSH-BUFFER
;)

(DEFUN BRUSH-PAINT (BRUSH PAINT X0 Y0 &OPTIONAL XOR-MODE
                      &AUX BW BH BBA BUFFER-PIXELS
                           ZX ZY ZXW ZYW ZXD ZYD PBA PAINT-X PAINT-Y)
        (SETQ BBA (<- BRUSH ':PAINT-AREA-BUFFER-ARRAY))
        (SETQ BW (<- BRUSH ':PAINT-AREA-X-SIZE))
        (SETQ BH (<- BRUSH ':PAINT-AREA-Y-SIZE))
        (SETQ BUFFER-PIXELS (SCREEN-BUFFER-PIXEL-ARRAY TV-DEFAULT-SCREEN))
        (SETQ X0 (- X0 (// BW 2))
              Y0 (- Y0 (// BH 2)))
;COPY BRUSH TO BRUSH-BUFFER-ARRAY
        (<- BRUSH ':COPY-TO-BUFFER)
;CLEAR BRUSH REGION IN PICTURE
       (COND ((NULL XOR-MODE)
              (BITBLT TV-ALU-ANDCA BW BH
                      BBA 0 0
                      BUFFER-PIXELS X0 Y0)
;COMBINE PAINT WITH BRUSH-BUFFER, RESULT TO BRUSH-BUFFER
              (SETQ ZX (<- PAINT ':PAINT-AREA-X)                ;FIGURE OUT PAINT PHASE, ETC.
                    ZY (<- PAINT ':PAINT-AREA-Y)
                    ZXW (<- PAINT ':PAINT-AREA-X-SIZE)
                    ZYW (<- PAINT ':PAINT-AREA-Y-SIZE)
                    ZXD (- ZXW (\ ZX ZXW))      ;PHASE OF PAINT ORIGIN
                    ZYD (- ZYW (\ ZY ZYW))
                    PBA (<- PAINT ':PAINT-AREA-BUFFER-ARRAY))
              (SETQ PAINT-X (\ (+ X0 ZXD) ZXW)) ;COMPUTE PAINT RELATIVE X-COORD OF FIRST BIT
              (SETQ PAINT-Y (\ (+ Y0 ZYD) ZYW)) ;LIKEWISE Y
              (BITBLT TV-ALU-AND BW BH
                      PBA PAINT-X PAINT-Y
                      BBA 0 0)
;IOR BRUSH-BUFFER TO PICTURE
              (BITBLT TV-ALU-IOR BW BH
                      BBA 0 0
                      BUFFER-PIXELS X0 Y0))
             (T
              (BITBLT TV-ALU-XOR BW BH
                      BBA 0 0
                      BUFFER-PIXELS X0 Y0)))
)

;(DEFUN BRUSH-PAINT (BRUSH PAINT X0 Y0 &OPTIONAL XOR-MODE)
;  (PROG (B-IIDX B-IDX B-IOVER B-OVER B-IBC B-BC B-YC
;        PAINT-IIDX PAINT-IDX PAINT-IOVER PAINT-OVER PAINT-IXBC PAINT-XBC PAINT-YBC
;        PAINT-X PAINT-Y
;        ZX ZY ZXW ZYW ZXD ZYD
;        PICT-IIDX PICT-IDX PICT-IOVER PICT-OVER PICT-TEM PICT-FIELD
;        BITS BRUSH-WD PAINT-WD PICT-WD BUFFER-WORDS SCREEN-LINE-LOCATIONS)
;        (SETQ BUFFER-WORDS (SCREEN-BUFFER-HALFWORD-ARRAY TV-DEFAULT-SCREEN))
;        (SETQ SCREEN-LINE-LOCATIONS (* 2 (SCREEN-LOCATIONS-PER-LINE TV-DEFAULT-SCREEN)))
;  ;XXX-IDX IS A WORD INDEX INTO THE TV-BUFFER FOR XXX.
;  ;XXX-IIDX IS THE VALUE OF XXX-IDX AT START OF CURRENT X-LINE.  INCREMENT BY
;        ;(* 2 (SCREEN-LOCATIONS-PER-LINE TV-DEFAULT-SCREEN))  TIMES TWO BECAUSE TWO ARRAY ENTRIES
;       ; PER MEMORY WORD.
;       ; (# VIDEO BUFFER WDS IN X LINE) WHEN STARTING NEW X-LINE.
;  ;XXX-OVER IS HOW MANY BITS OVER WITHIN THAT WORD XXX IS.  THUS XXX-OVER CAN VARY FROM
;  ;  0 IF ALL 16. BITS ARE ACTIVE TO 17 IF ONLY ONE BIT IS.  NOTE THIS ACTUALLY POINTS
;  ;  "AT" OF THE ACTIVE BIT, READY TO GOBBLE IT ON DIRECTLY
;  ;  (UNLIKE SIMILAR TO PDP-10 ILDB INSTRUCTION).
;  ;XXX-IOVER IS VALUE OF XXX-OVER AT START OF X-LINE.
;  ;XXX-BC IS BIT COUNT OF BITS REMAINING IN XXX IN CURRENT X-LINE.
;; BITS IS SET TO THE MINIMUM OF
;;   1- NUMBER OF BRUSH BITS REMAINING IN CURRENT X-LINE.
;;   2- NUMBER OF BRUSH BITS IN CURRENT BRUSH WD.
;;   3- NUMBER OF PAINT BITS REMAINING ALTOGETHER (BEFORE X WRAP REQD).
;;   4- NUMBER OF PAINT BITS IN CURRENT PAINT WD.
;;   5- NUMBER OF PICTURE BITS IN CURRENT PICTURE WD.
;; THEN THIS NUMBER OF BITS ARE PROCESSED.  (NOTE THAT NO WORD BOUNDARIES CAN BE
;;   CROSSED IN ANY OF THE BRUSH, PAINT OR PICTURE).
;; THEN ALL THE POINTERS ARE INCREMENTED BY BITS, AND ANOTHER LOOP MADE, IF NECC, ETC.
;
;       (SETQ B-IIDX (+ (LSH (CAR BRUSH) -4) (* (CADR BRUSH) SCREEN-LINE-LOCATIONS)))
;       (SETQ B-IOVER (LOGAND (CAR BRUSH) 17))
;       (SETQ B-IBC (CADDR BRUSH))
;       (SETQ B-YC (CADDDR BRUSH))      ;COUNT OF Y-LINES
;
;       (SETQ X0 (- X0 (// B-IBC 2))    ;MOVE FROM CENTER OF BRUSH TO UPPER LEFT
;             Y0 (- Y0 (// B-YC 2)))
;
;        (SETQ ZX (CAR PAINT)           ;FIGURE OUT PAINT PHASE, ETC.
;              ZY (CADR PAINT)
;              ZXW (CADDR PAINT)
;              ZYW (CADDDR PAINT)
;             ZXD (- ZXW (\ ZX ZXW))    ;PHASE OF PAINT ORIGIN
;             ZYD (- ZYW (\ ZY ZYW)))
;
;       (SETQ PAINT-X (\ (+ X0 ZXD) ZXW))       ;COMPUTE PAINT RELATIVE X-COORD OF FIRST BIT
;       (SETQ PAINT-IXBC (- ZXW PAINT-X))       ;THIS MANY BITS AVAIL BEFORE MUST WRAP
;       (SETQ PAINT-Y (\ (+ Y0 ZYD) ZYW))       ;LIKEWISE Y
;       (SETQ PAINT-YBC (- ZYW PAINT-Y))
;
;       (SETQ PAINT-IIDX (+ (LSH (+ PAINT-X ZX) -4) (* (+ PAINT-Y ZY)
;                                                       SCREEN-LINE-LOCATIONS)))
;       (SETQ PAINT-IOVER (LOGAND (+ PAINT-X ZX) 17))
;
;       (SETQ PICT-IIDX (+ (LSH X0 -4) (* Y0 SCREEN-LINE-LOCATIONS)))
;       (SETQ PICT-IOVER (LOGAND X0 17))
;
;  XL   (SETQ B-IDX B-IIDX PAINT-IDX PAINT-IIDX PICT-IDX PICT-IIDX   ;START NEW X-LINE
;             B-OVER B-IOVER PAINT-OVER PAINT-IOVER PICT-OVER PICT-IOVER
;             PAINT-XBC PAINT-IXBC B-BC B-IBC)
;  L    (SETQ BITS (MIN (- 20 (MAX B-OVER PAINT-OVER PICT-OVER)) PAINT-XBC B-BC))
;       (SETQ BRUSH-WD (LDB (+ (LSH B-OVER 6)
;                               BITS)
;                            (AR-1 BUFFER-WORDS B-IDX)))
;       (SETQ PAINT-WD (LDB (+ (LSH PAINT-OVER 6)
;                               BITS)
;                            (AR-1 BUFFER-WORDS PAINT-IDX)))
;       (SETQ PICT-WD (LDB (SETQ PICT-FIELD
;                             (+ (LSH PICT-OVER 6)
;                                BITS))
;                           (SETQ PICT-TEM (AR-1 BUFFER-WORDS PICT-IDX))))
;       (SETQ PAINT-WD (LOGAND PAINT-WD BRUSH-WD))
;       (SETQ PICT-WD (COND (XOR-MODE (LOGXOR PICT-WD BRUSH-WD))
;                           (T (LOGIOR (LOGAND PICT-WD (LOGXOR -1 BRUSH-WD))
;                                       PAINT-WD))))
;       (AS-1 (DPB PICT-WD PICT-FIELD PICT-TEM) BUFFER-WORDS PICT-IDX)
;       (COND ((ZEROP (SETQ B-BC (- B-BC BITS)))        ;THRU WITH BRUSH IN X DIRECTION
;               (COND ((ZEROP (SETQ B-YC (1- B-YC)))
;                      (RETURN T))                      ;THRU IN Y, TOO.
;                     (T (SETQ PAINT-IIDX (+ PAINT-IIDX SCREEN-LINE-LOCATIONS)
;                              B-IIDX (+ B-IIDX SCREEN-LINE-LOCATIONS)
;                              PICT-IIDX (+ PICT-IIDX SCREEN-LINE-LOCATIONS) )
;                        (COND ((ZEROP (SETQ PAINT-YBC (1- PAINT-YBC)))  ;WRAP PAINT IN Y
;                               (SETQ PAINT-YBC ZYW)                     ; DIRECTION
;                               (SETQ PAINT-IIDX (- PAINT-IIDX
;                                                   (* SCREEN-LINE-LOCATIONS ZYW)))))
;                        (GO XL)))  ))
;       (COND ((ZEROP (SETQ PAINT-XBC (- PAINT-XBC BITS)))
;               (SETQ PAINT-XBC ZXW)
;               (SETQ PAINT-OVER (LOGAND ZX 17))
;               (SETQ PAINT-IDX (+ (LSH ZX -4)
;                                  (* SCREEN-LINE-LOCATIONS
;                                     (// PAINT-IDX SCREEN-LINE-LOCATIONS)))))      ;SAME Y LINE AS BEFORE
;              ((>= (SETQ PAINT-OVER (+ PAINT-OVER BITS)) 20)
;               (SETQ PAINT-OVER 0 PAINT-IDX (1+ PAINT-IDX))))
;       (COND ((>= (SETQ B-OVER (+ B-OVER BITS)) 20)
;               (SETQ B-OVER 0 B-IDX (1+ B-IDX))))
;       (COND ((>= (SETQ PICT-OVER (+ PICT-OVER BITS)) 20)
;               (SETQ PICT-OVER 0 PICT-IDX (1+ PICT-IDX))))
;       (GO L) ))

;(DEFUN BRUSH-PAINT (BRUSH PAINT X0 Y0 &OPTIONAL XOR-MODE)
;  (PROG (PX PY BX BY BXL BYL ZX ZY ZXW ZYW ZXD ZYD PB)
;        (SETQ ZX (CAR PAINT)
;              ZY (CADR PAINT)
;              ZXW (CADDR PAINT)
;              ZYW (CADDDR PAINT)
;             ZXD (- ZXW (\ ZX ZXW))  ;THESE VARIABLES ARE SO THAT IF THE PAINT ITSELF
;             ZYD (- ZYW (\ ZY ZYW)))     ; IS PAINTED OVER, EACH BIT IS EXACTLY PAINTED
;                       ;OVER WITH ITSELF.  THIS ASSURES THE PAINT IS UNCHANGED AND ALSO
;                       ;THAT WALL-PAPER PATTERNS "LINE UP"
;        (SETQ PY (- Y0 (// (CADDDR BRUSH) 2))
;              BY (CADR BRUSH)
;              BYL (+ BY (CADDDR BRUSH)))
;   L    (COND ((NOT (< BY BYL))
;               (RETURN T)))
;        (SETQ PX (- X0 (// (CADDR BRUSH) 2))
;              BX (CAR BRUSH)
;              BXL (+ BX (CADDR BRUSH)))
;   L1   (COND ((NOT (< BX BXL))
;               (SETQ BY (1+ BY))
;               (SETQ PY (1+ PY))
;               (GO L)))
;        (SETQ PB (AR-2 (SCREEN-BUFFER-PIXEL-ARRAY TV-DEFAULT-SCREEN)
;                       (+ ZX (\ (+ PX ZXD) ZXW))
;                       (+ ZY (\ (+ PY ZYD) ZYW))))
;        (COND ((NOT (= 0 (AR-2 (SCREEN-BUFFER-PIXEL-ARRAY TV-DEFAULT-SCREEN) BX BY)))
;               (AS-2 (COND (XOR-MODE (LOGXOR 1 (AR-2 (SCREEN-BUFFER-PIXEL-ARRAY TV-DEFAULT-SCREEN) PX PY)))
;                           (T PB))
;                     (SCREEN-BUFFER-PIXEL-ARRAY TV-DEFAULT-SCREEN) PX PY)))
;        (SETQ PX (1+ PX)
;              BX (1+ BX))
;        (GO L1)))

(DEFUN INIT-PAINT (X0 Y0 PATTERN-LIST
                      &OPTIONAL (ARY (SCREEN-BUFFER-PIXEL-ARRAY TV-DEFAULT-SCREEN)))
  (PROG (X Y XL YL PAT COUNT)
        (SETQ Y Y0
              XL (+ X0 40)
              YL (+ Y0 40)
              PAT PATTERN-LIST)
   L    (COND ((NOT (< Y YL))
;              (RETURN (LIST X0 Y0 40 40))
               (RETURN (<- PAINT-AREA-CLASS ':NEW
                           'PAINT-AREA-ARRAY ARY
                           'PAINT-AREA-X X0
                           'PAINT-AREA-Y Y0
                           'PAINT-AREA-X-SIZE 40
                           'PAINT-AREA-Y-SIZE 40))))
        (SETQ X X0
              COUNT -3)
   XL   (AS-2 (LSH (CAR PAT) COUNT) ARY X Y)
        (COND ((NOT (< X XL))
               (SETQ Y (1+ Y))
               (COND ((NULL (SETQ PAT (CDR PAT)))
                      (SETQ PAT PATTERN-LIST)))
               (GO L)))
        (SETQ X (1+ X))
        (COND ((> (SETQ COUNT (1+ COUNT))
                  0)
               (SETQ COUNT -3)))
        (GO XL)))

(DEFUN INIT-PAINTS NIL
  (PROG ((X 0) (Y 10) (PL '((0 0 0 0) (1 0 0 4) (2 10 2 10)
          (1 12 2 14) (5 12 5 12) (16 5 15 3)
          (15 7 15 7) (16 17 17 13) (17 17 17 17)))
         (BL '((600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600)
               (0 0 0 0 0 0 0 177777 177777 0 0 0 0 0 0 0)
               (177777 177777 177777 177777 177777 177777 177777 177777
                    177777 177777 177777 177777 177777 177777 177777 177777)
               (0 0 0 0 7760 7760 7760 7760 7760 7760 7760 7760 0 0 0 0)
               (600 3740 17770 37774 37774 77776 77776 177777 177777 77776
                    77776 37774 37774 17770 3740 600)
               (0 0 0 0 1700 3740 7760 7760 7760 7760 3740 1700 0 0 0 0)
               (0 0 0 0 0 0 200 200 200 200 0 0 0 0 0 0)
               (0 0 0 0 0 0 0 1700 0 0 0 0 0 0 0 0)))
         (COUNT 0))
        (TV-SELECT-SCREEN TV-DEFAULT-SCREEN)
        (TV-ERASE (SCREEN-WIDTH TV-DEFAULT-SCREEN) 50 0 0 TV-ALU-ANDCA)
        (SETQ PAINT-AREA-Y 50)                  ;MAX Y OF MAIN PAINT AREA
        (SETQ PAINT-LIST NIL)
   L    (COND ((NULL PL)
               (SETQ PAINT-AREA-X X)            ;MAX X OF MAIN PAINT AREA
               (SETQ X (+ X 40))
               (SETQ COUNT 0)
               (GO L1)))
        (SETQ PAINT-LIST (CONS (INIT-PAINT X Y (CAR PL))
                               PAINT-LIST))
        (COND ((= COUNT 0)              ;ERASING PAINT
               (SETQ ALTERNATE-PAINT (CAR PAINT-LIST))
               (<- ALTERNATE-PAINT ':COPY-TO-BUFFER))
              ((= COUNT 4)              ;INITIAL PAINT
               (SETQ PAINT (CAR PAINT-LIST))
               (<- PAINT ':COPY-TO-BUFFER)))
        (SETQ X (+ X 42)
              PL (CDR PL))
        (SETQ COUNT (1+ COUNT))
        (GO L)
   L1   (COND ((NULL BL)
               (RETURN T)))
        (SETQ PAINT-LIST (CONS (INIT-BRUSH X
                                           (+ Y 10)
                                           (CAR BL))
                               PAINT-LIST))
        (COND ((= COUNT 3)
               (SELECT-BRUSH (CAR PAINT-LIST))))
        (SETQ X (+ X 24)
              BL (CDR BL))
        (SETQ COUNT (1+ COUNT))
        (GO L1)))

;(DEFUN PAINT-SELECT-ARRAY (X Y)
;  (PROG (TEM)
;       (SETQ TEM PAINT-LIST)
;   L   (COND ((NULL TEM) (RETURN NIL))
;             ((AND (< (CAAR TEM) X)
;                   (< (CADAR TEM) Y)
;                   (< X (+ (CAAR TEM) (CADDAR TEM)))
;                   (< Y (+ (CADAR TEM) (CAR (CDDDAR TEM)))))
;               (RETURN (CAR TEM))))
;       (SETQ TEM (CDR TEM))
;       (GO L)))

(DEFUN PAINT-SELECT-ARRAY (X Y &OPTIONAL (ARY (SCREEN-BUFFER-PIXEL-ARRAY TV-DEFAULT-SCREEN)))
    (DO ((P PAINT-LIST (CDR P)))
        ((NULL P))
      (COND ((<- (CAR P) ':INSIDE-P ARY X Y)
             (RETURN (CAR P))))))

(DEFUN INIT-BRUSH (X0 Y0 PATTERN-LIST
                      &OPTIONAL (ARY (SCREEN-BUFFER-PIXEL-ARRAY TV-DEFAULT-SCREEN)))
  (PROG (X Y XL YL PAT COUNT)
        (SETQ Y Y0
              XL (+ X0 20)
              YL (+ Y0 20)
              PAT PATTERN-LIST)
   L    (COND ((NOT (< Y YL))
;              (RETURN (LIST X0 Y0 20 20))
               (RETURN (<- PAINT-AREA-CLASS ':NEW
                           'PAINT-AREA-ARRAY ARY
                           'PAINT-AREA-X X0
                           'PAINT-AREA-Y Y0
                           'PAINT-AREA-X-SIZE 20
                           'PAINT-AREA-Y-SIZE 20))))
        (SETQ X X0
              COUNT -17)
   XL   (AS-2 (LSH (CAR PAT) COUNT) (SCREEN-BUFFER-PIXEL-ARRAY TV-DEFAULT-SCREEN) X Y)
        (COND ((NOT (< X XL))
               (SETQ Y (1+ Y))
               (SETQ PAT (CDR PAT))
               (GO L)))
        (SETQ X (1+ X))
        (SETQ COUNT (1+ COUNT))
        (GO XL)))

(DEFPROP SAVE-SCREEN PAINT-COM-SAVE-SCREEN PAINT-COMMAND)
(DEFUN PAINT-COM-SAVE-SCREEN NIL
       (SAVE-SCREEN))

(DEFUN SAVE-SCREEN NIL
    (COND ((NULL (BOUNDP 'PAINT-SAVED-SCREEN))
           (SETQ PAINT-SAVED-SCREEN
                 (MAKE-ARRAY DEFAULT-ARRAY-AREA 'ART-16B
                             (ARRAY-DIMENSION-N 1 (SCREEN-BUFFER-HALFWORD-ARRAY TV-DEFAULT-SCREEN))))))
    (COPY-ARRAY-1 (SCREEN-BUFFER-HALFWORD-ARRAY TV-DEFAULT-SCREEN) PAINT-SAVED-SCREEN))

(DEFPROP RESTORE-SCREEN PAINT-COM-RESTORE-SCREEN PAINT-COMMAND)
(DEFUN PAINT-COM-RESTORE-SCREEN NIL
       (RESTORE-SCREEN))

(DEFUN RESTORE-SCREEN NIL
    (COND ((NULL (BOUNDP 'PAINT-SAVED-SCREEN))
           NIL)
          (T (COPY-ARRAY-1 PAINT-SAVED-SCREEN (SCREEN-BUFFER-HALFWORD-ARRAY TV-DEFAULT-SCREEN)))))

(DEFPROP DRAW-LINES-AND-CIRCLES PAINT-COM-DRAW-LINES-AND-CIRCLES PAINT-COMMAND)
(DEFPROP DRAW-LINES-AND-CIRCLES PAINT-COM-DLC-ENTER PAINT-ENTERING-FCTN)
(DEFPROP DRAW-LINES-AND-CIRCLES PAINT-COM-DLC-LEAVE PAINT-LEAVING-FCTN)
(DEFPROP DRAW-LINES-AND-CIRCLES T PAINT-DISPATCH-ALWAYS)
(DEFPROP DRAW-LINES-AND-CIRCLES 300 PAINT-CLOCK-RATE)

(DEFUN PAINT-COM-DLC-ENTER NIL
       (SETQ PAINT-DLC-STATE 'SET-BASEPOINT)
       (SETQ PAINT-DLC-MODE 'LINE))

(DEFUN PAINT-COM-DRAW-LINES-AND-CIRCLES NIL
       (COND (MOUSE-MID-SWITCH
              (PAINT-DLC-ADVANCE)
              (SETQ MOUSE-MIDSW-HOLD T))
             (T (PAINT-DLC-BLINK)))
       (COND ((AND MOUSE-BOT-SWITCH (NULL MOUSE-BOTSW-HOLD))
              (PAINT-DLC-ALTER)
              (SETQ MOUSE-BOTSW-HOLD T))))

(DEFUN PAINT-DLC-ADVANCE NIL
       (COND ((EQ PAINT-DLC-STATE 'SET-BASEPOINT)
              (SETQ PAINT-DLC-BASE-X MOUSE-X)
              (SETQ PAINT-DLC-BASE-Y MOUSE-Y)
              (SETQ PAINT-SUBC-PHASE NIL)
              (SETQ PAINT-DLC-STATE
                    (COND ((EQ PAINT-DLC-MODE 'LINE) 'RUBBER-BAND)
                          ((EQ PAINT-DLC-MODE 'CIRCLE) 'RUBBER-CIRCLE))))
             ((MEMQ PAINT-DLC-STATE '(RUBBER-BAND RUBBER-CIRCLE))
                    (COND (PAINT-SUBC-X
                           (COND ((EQ PAINT-DLC-STATE 'RUBBER-BAND)
                                  (DRAW-ABSOLUTE-VECTOR-RASTER-COORDS
                                    PAINT-DLC-BASE-X PAINT-DLC-BASE-Y
                                    PAINT-SUBC-X PAINT-SUBC-Y 'IOR))
                                 ((EQ PAINT-DLC-STATE 'RUBBER-CIRCLE)
                                  (DRAW-ABSOLUTE-CIRCLE-RASTER-COORDS
                                    PAINT-DLC-BASE-X PAINT-DLC-BASE-Y
                                    PAINT-SUBC-X PAINT-SUBC-Y 'IOR)))
                           (SETQ PAINT-SUBC-X NIL)))
                    (SETQ PAINT-SUBC-PHASE NIL)
                    (SETQ PAINT-DLC-STATE 'SET-BASEPOINT))))

(DEFUN PAINT-DLC-BLINK NIL
       (COND ((NULL PAINT-SUBC-PHASE)
              (PAINT-DLC-SET))
             (T (PAINT-DLC-CLEAR))))

(DEFUN PAINT-DLC-SET NIL
       (COND ((NULL PAINT-SUBC-PHASE)
              (SETQ PAINT-SUBC-X MOUSE-X PAINT-SUBC-Y MOUSE-Y)
              (COND ((EQ PAINT-DLC-STATE 'RUBBER-BAND)
                     (DRAW-ABSOLUTE-VECTOR-RASTER-COORDS
                      PAINT-DLC-BASE-X PAINT-DLC-BASE-Y
                      PAINT-SUBC-X PAINT-SUBC-Y 'XOR))
                    ((EQ PAINT-DLC-STATE 'RUBBER-CIRCLE)
                     (DRAW-ABSOLUTE-CIRCLE-RASTER-COORDS
                      PAINT-DLC-BASE-X PAINT-DLC-BASE-Y
                      PAINT-SUBC-X PAINT-SUBC-Y 'XOR)))
              (SETQ PAINT-SUBC-PHASE T))))

(DEFUN PAINT-DLC-CLEAR NIL
       (COND (PAINT-SUBC-PHASE
              (COND ((EQ PAINT-DLC-STATE 'RUBBER-BAND)
                     (DRAW-ABSOLUTE-VECTOR-RASTER-COORDS
                                PAINT-DLC-BASE-X PAINT-DLC-BASE-Y
                                PAINT-SUBC-X PAINT-SUBC-Y 'XOR))
                    ((EQ PAINT-DLC-STATE 'RUBBER-CIRCLE)
                     (DRAW-ABSOLUTE-CIRCLE-RASTER-COORDS
                      PAINT-DLC-BASE-X PAINT-DLC-BASE-Y
                      PAINT-SUBC-X PAINT-SUBC-Y 'XOR)))
              (SETQ PAINT-SUBC-PHASE NIL))))

(DEFUN PAINT-DLC-ALTER NIL
       (PAINT-DLC-CLEAR)
       (SETQ PAINT-DLC-MODE (COND ((EQ PAINT-DLC-MODE 'LINE) 'CIRCLE)
                                  (T 'LINE)))
       (COND ((EQ PAINT-DLC-STATE 'RUBBER-BAND)
              (SETQ PAINT-DLC-STATE 'RUBBER-CIRCLE))
             ((EQ PAINT-DLC-STATE 'RUBBER-CIRCLE)
              (SETQ PAINT-DLC-STATE 'RUBBER-BAND))))

(DEFUN PAINT-COM-DLC-LEAVE NIL NIL)

(DEFUN COPY-ARRAY-1 (FROM TO)
 (PROG (LIM LIM2)
       (COND ((< (SETQ LIM2 (ARRAY-LENGTH FROM))
                 (SETQ LIM (ARRAY-LENGTH TO)))
              (SETQ LIM LIM2)))
       (DO I (1- LIM) (1- I) (= I 0)
           (AS-1 (AR-1 FROM I)
                 TO
                 I))))

(DEFPROP EXIT PAINT-COM-EXIT PAINT-COMMAND)
(DEFPROP EXIT PAINT-COM-EXIT PAINT-ENTERING-FCTN)  ;REALLY TRY TO GET THERE
(DEFPROP EXIT T PAINT-DISPATCH-ALWAYS)
(DEFPROP EXIT 1 PAINT-CLOCK-RATE)

(DEFUN PAINT-COM-EXIT NIL (SETQ PAINT-EXIT-FLAG T))

(DEFPROP TEXT PAINT-COM-TEXT-ENTER PAINT-ENTERING-FCTN)
(DEFPROP TEXT PAINT-COM-TEXT PAINT-COMMAND)
(DEFPROP TEXT PAINT-COM-TEXT-LEAVE PAINT-LEAVING-FCTN)
(DEFPROP TEXT T PAINT-DISPATCH-ALWAYS)
(DEFPROP TEXT 300 PAINT-CLOCK-RATE)

(DEFUN PAINT-COM-TEXT-ENTER NIL
   (SETQ PAINT-TEXT-HOLDING-STRING (MAKE-ARRAY DEFAULT-ARRAY-AREA 'ART-STRING 50 NIL '(0))))

(DEFUN PAINT-COM-TEXT (&AUX TEM)
       (COND (MOUSE-MID-SWITCH
              (PAINT-TEXT-ADVANCE)
              (SETQ MOUSE-MIDSW-HOLD T))
             (T (PAINT-TEXT-BLINK)))
       (COND ((AND MOUSE-BOT-SWITCH
                   (NULL MOUSE-BOTSW-HOLD)
                   PAINT-SUBC-X
                   (NOT (ZEROP (ARRAY-ACTIVE-LENGTH PAINT-ARG-STRING)))
                   (BOUNDP (SETQ TEM (INTERN PAINT-ARG-STRING)))
                   (ARRAYP (SYMEVAL TEM)))
              (SETQ PAINT-TEXT-FONT (SYMEVAL TEM))
              (PAINT-TEXT-CLEAR)
              (SETQ PAINT-SUBC-X NIL)
              (STORE-ARRAY-LEADER 0 PAINT-ARG-STRING 0)
              )))

(DEFUN PAINT-TEXT-ADVANCE NIL
       (COND (PAINT-SUBC-X
              (PAINT-TEXT-SET)
              (STORE-ARRAY-LEADER 0 PAINT-ARG-STRING 0)  ;RESET STRING ARG
              (SETQ PAINT-SUBC-X NIL)
              (SETQ PAINT-SUBC-PHASE NIL))))

(DEFUN PAINT-COM-TEXT-LEAVE NIL
   (RETURN-ARRAY PAINT-TEXT-HOLDING-STRING))

(DEFUN PAINT-TEXT-BLINK NIL
       (COND ((NULL PAINT-SUBC-PHASE)
              (PAINT-TEXT-SET))
             (T (PAINT-TEXT-CLEAR))))

(DEFUN PAINT-TEXT-SET NIL
       (COND ((NULL PAINT-SUBC-PHASE)
              (SETQ PAINT-SUBC-X MOUSE-X PAINT-SUBC-Y MOUSE-Y)
              (COPY-ARRAY-CONTENTS-AND-LEADER PAINT-ARG-STRING PAINT-TEXT-HOLDING-STRING)
              (PAINT-TEXT-DRAW)
              (SETQ PAINT-SUBC-PHASE T))))

(DEFUN PAINT-TEXT-CLEAR NIL
       (COND (PAINT-SUBC-PHASE
              (PAINT-TEXT-DRAW)
              (SETQ PAINT-SUBC-PHASE NIL))))

(DEFUN PAINT-TEXT-DRAW NIL
      (TV-SET-CURSORPOS PAINT-LABELING-PC-PPR PAINT-SUBC-X PAINT-SUBC-Y)
      (TV-SET-FONT PAINT-LABELING-PC-PPR PAINT-TEXT-FONT)
      (TV-STRING-OUT PAINT-LABELING-PC-PPR
                     PAINT-TEXT-HOLDING-STRING)
)
